home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / lib / tclX6.4c / dist / tclsrc / setfuncs.tcl < prev    next >
Encoding:
Text File  |  1992-11-07  |  3.4 KB  |  128 lines
  1. #
  2. # setfuncs --
  3. #
  4. # Perform set functions on lists.  Also has a procedure for removing duplicate
  5. # list entries.
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992 Karl Lehenbauer and Mark Diekhans.
  8. #
  9. # Permission to use, copy, modify, and distribute this software and its
  10. # documentation for any purpose and without fee is hereby granted, provided
  11. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12. # Mark Diekhans make no representations about the suitability of this
  13. # software for any purpose.  It is provided "as is" without express or
  14. # implied warranty.
  15. #------------------------------------------------------------------------------
  16. # $Id: setfuncs.tcl,v 2.0 1992/10/16 04:52:10 markd Rel $
  17. #------------------------------------------------------------------------------
  18. #
  19.  
  20. #@package: TclX-set_functions union intersect intersect3 lrmdups
  21.  
  22. #
  23. # return the logical union of two lists, removing any duplicates
  24. #
  25. proc union {lista listb} {
  26.     set full_list [lsort [concat $lista $listb]]
  27.     set check_element [lindex $full_list 0]
  28.     set outlist $check_element
  29.     foreach element [lrange $full_list 1 end] {
  30.     if {$check_element == $element} continue
  31.     lappend outlist $element
  32.     set check_element $element
  33.     }
  34.     return $outlist
  35. }
  36.  
  37. #
  38. # sort a list, returning the sorted version minus any duplicates
  39. #
  40. proc lrmdups {list} {
  41.     set list [lsort $list]
  42.     set result [lvarpop list]
  43.     lappend last $result
  44.     foreach element $list {
  45.     if {$last != $element} {
  46.         lappend result $element
  47.         set last $element
  48.     }
  49.     }
  50.     return $result
  51. }
  52.  
  53. #
  54. # intersect3 - perform the intersecting of two lists, returning a list
  55. # containing three lists.  The first list is everything in the first
  56. # list that wasn't in the second, the second list contains the intersection
  57. # of the two lists, the third list contains everything in the second list
  58. # that wasn't in the first.
  59. #
  60.  
  61. proc intersect3 {list1 list2} {
  62.     set list1Result ""
  63.     set list2Result ""
  64.     set intersectList ""
  65.  
  66.     set list1 [lrmdups $list1]
  67.     set list2 [lrmdups $list2]
  68.  
  69.     while {1} {
  70.         if [lempty $list1] {
  71.             if ![lempty $list2] {
  72.                 set list2Result [concat $list2Result $list2]
  73.             }
  74.             break
  75.         }
  76.         if [lempty $list2] {
  77.         set list1Result [concat $list1Result $list1]
  78.             break
  79.         }
  80.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  81.  
  82.         if {$compareResult < 0} {
  83.             lappend list1Result [lvarpop list1]
  84.             continue
  85.         }
  86.         if {$compareResult > 0} {
  87.             lappend list2Result [lvarpop list2]
  88.             continue
  89.         }
  90.         lappend intersectList [lvarpop list1]
  91.         lvarpop list2
  92.     }
  93.     return [list $list1Result $intersectList $list2Result]
  94. }
  95.  
  96. #
  97. # intersect - perform an intersection of two lists, returning a list
  98. # containing every element that was present in both lists
  99. #
  100. proc intersect {list1 list2} {
  101.     set intersectList ""
  102.  
  103.     set list1 [lsort $list1]
  104.     set list2 [lsort $list2]
  105.  
  106.     while {1} {
  107.         if {[lempty $list1] || [lempty $list2]} break
  108.  
  109.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  110.  
  111.         if {$compareResult < 0} {
  112.             lvarpop list1
  113.             continue
  114.         }
  115.  
  116.         if {$compareResult > 0} {
  117.             lvarpop list2
  118.             continue
  119.         }
  120.  
  121.         lappend intersectList [lvarpop list1]
  122.         lvarpop list2
  123.     }
  124.     return $intersectList
  125. }
  126.  
  127.  
  128.